home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / gfaxpert.lzh / START / GFASTART.GFA (.txt) next >
Encoding:
GFA-BASIC Atari  |  1986-10-19  |  9.9 KB  |  496 lines
  1. ' ********************
  2. ' *** GFASTART.GFA ***    compile as *** GFASTART.PRG ***
  3. ' ********************
  4. ' *** this program runs in all resolutions
  5. ' *** 'Shell'-program for running compiled GFA-programs
  6. ' *** put GFASTART.PRG in the main directory
  7. ' *** programs should exit with CHAIN "\GFASTART.PRG"
  8. ' *** © Han Kempen (22-1-'90)
  9. '
  10. DEFWRD "a-z"
  11. '
  12. start$="\GFASTART.INF"          ! last path saved here
  13. '
  14. CLS
  15. ' @check.boot                   ! check for boot-virus (not activated)
  16. '
  17. drive$=CHR$(65+GEMDOS(25))      ! current drive
  18. '
  19. bytes%=DFREE(0)                 ! slow on harddisk (unless FATSPEED installed)
  20. current$=drive$+": "+STR$(bytes%)+" bytes free"
  21. '
  22. IF EXIST(start$)
  23.   OPEN "I",#1,start$            ! last accessed folder in GFASTART.INF
  24.   INPUT #1,path$
  25.   CLOSE #1
  26. ELSE
  27.   path$=drive$+":\"             ! main directory
  28. ENDIF
  29. '
  30. SELECT XBIOS(4)                 ! examine resolution
  31. CASE 2
  32.   high.res!=TRUE
  33.   scrn.col.max&=80
  34.   fac&=1
  35. CASE 1
  36.   med.res!=TRUE
  37.   scrn.col.max&=80
  38.   fac&=2
  39. CASE 0
  40.   low.res!=TRUE
  41.   scrn.col.max&=40
  42. ENDSELECT
  43. '
  44. IF high.res!
  45.   VSETCOLOR 1,0
  46. ELSE IF med.res!
  47.   @standard.med.colors
  48. ELSE
  49.   @standard.low.colors
  50. ENDIF
  51. '
  52. IF PEEK(&H444)<>0               ! not perfect
  53.   IF low.res! OR med.res!
  54.     SPOKE &HFF820A,252          ! NOT if you use a TV through a modulator !!
  55.     PRINT
  56.     PRINT " Vertical frequency now 60 Hz"
  57.   ENDIF
  58.   '
  59.   SPOKE &H444,0
  60.   PRINT
  61.   PRINT " Write Verify Test switched off"
  62.   '
  63.   IF VAL(RIGHT$(DATE$,2))<88            ! not perfect either
  64.     HIDEM
  65.     IF med.res! OR high.res!
  66.       LOCATE 1,9
  67.       PRINT @center$("START-SHELL")
  68.       DEFLINE 1,5
  69.       RBOX 22*8,10*16/fac&,58*8,15*16/fac&
  70.       LOCATE 25,12
  71.       @start.date.input
  72.       LOCATE 25,14
  73.       @start.time.input
  74.       DEFLINE 1,1
  75.     ELSE
  76.       LOCATE 1,9
  77.       PRINT @center$("STARTLOW-SHELL")
  78.       DEFLINE 1,3
  79.       RBOX 2*8,10*8,38*8,15*8
  80.       LOCATE 4,12
  81.       @start.date.input
  82.       LOCATE 4,14
  83.       @start.time.input
  84.       DEFLINE 1,1
  85.     ENDIF
  86.     SHOWM
  87.   ENDIF
  88. ENDIF
  89. '
  90. IF high.res! OR med.res!
  91.   SELECT DPEEK(&H4A6)           ! first check if two drives connected
  92.   CASE 1
  93.     drive$="A "
  94.   CASE 2
  95.     drive$="A B "
  96.   ENDSELECT
  97.   FOR n&=2 TO 15                 ! now check other drives
  98.     IF BTST(BIOS(10),n&)
  99.       drive$=drive$+CHR$(n&+65)+" "
  100.     ENDIF
  101.   NEXT n&
  102.   bottom$="drives: "+drive$+"     "+current$
  103. ELSE
  104.   bottom$=current$
  105. ENDIF
  106. '
  107. CLS
  108. LOCATE 1,25
  109. PRINT @center$(bottom$)
  110. '
  111. m$="Choose program      <Cancel> = Quit"
  112. REPEAT
  113.   @fileselect(path$+"*.PRG","",m$,file$)
  114. UNTIL file$="" OR RIGHT$(file$)="\" OR RIGHT$(file$,4)=".PRG"
  115. '
  116. CLS
  117. IF file$="" OR RIGHT$(file$)="\"
  118.   ' *** user wants to quit
  119.   IF EXIST(start$)
  120.     KILL start$         ! kill GFASTART.INF
  121.   ENDIF
  122.   SYSTEM
  123. ELSE
  124.   ' *** user chose *.PRG-file
  125.   @parse.filename(file$,d$,p$,f$,e$)
  126.   path$=d$+":"+p$
  127.   OPEN "O",#1,start$
  128.   PRINT #1,path$        ! remember last path
  129.   CLOSE #1
  130.   CHAIN file$           ! start the program
  131. ENDIF
  132. '
  133. ' ------------------------------------------------------------------------------
  134. '
  135. DEFFN center$(text$)=SPACE$((scrn.col.max&-LEN(text$))/2)+text$
  136. '
  137. > PROCEDURE check.boot
  138.   ' *** compute checksum of bootsector and warn user if bootsector executable
  139.   LOCAL drive&,buffer$,buffer%,sum%,n&,m$
  140.   PRINT " Checking boot-sector ..."
  141.   drive&=GEMDOS(&H19)
  142.   buffer$=SPACE$(512)
  143.   buffer%=VARPTR(buffer$)
  144.   ~BIOS(4,0,L:buffer%,1,0,drive&)    ! bootsector (0) of current drive in buffer
  145.   sum%=0
  146.   FOR n&=0 TO 255
  147.     ADD sum%,CARD{buffer%+n&*2}
  148.   NEXT n&
  149.   sum%=sum% AND &HFFFF
  150.   IF sum%=&H1234
  151.     m$="Bootsector|executable :|this could be|a boot-virus"
  152.     ALERT 3,m$,2," OK |STOP",k&
  153.   ENDIF
  154. RETURN
  155. ' **********
  156. '
  157. > PROCEDURE get.path(VAR default.path$)
  158.   ' *** return default path (current drive and folder)
  159.   ' *** e.g. A:\GAMES\
  160.   LOCAL default.drive&,default.drive$,buffer$,buffer%
  161.   CLR default.path$
  162.   default.drive&=GEMDOS(&H19)
  163.   default.drive$=CHR$(default.drive&+65)
  164.   buffer$=SPACE$(64)
  165.   buffer%=VARPTR(buffer$)
  166.   VOID GEMDOS(&H47,L:buffer%,0)
  167.   default.path$=CHAR{buffer%}
  168.   IF default.path$<>""
  169.     default.path$=default.drive$+":"+default.path$+"\"
  170.   ELSE
  171.     default.path$=default.drive$+":\"
  172.   ENDIF
  173. RETURN
  174. ' **********
  175. '
  176. > PROCEDURE standard.med.colors
  177.   ' *** standard-colors for Medium resolution
  178.   LOCAL n&,col$,r&,g&,b&
  179.   RESTORE col.med.data
  180.   FOR n&=0 TO 3
  181.     READ col$
  182.     r&=VAL(LEFT$(col$))
  183.     g&=VAL(MID$(col$,2,1))
  184.     b&=VAL(RIGHT$(col$))
  185.     VSETCOLOR n&,r&,g&,b&
  186.   NEXT n&
  187.   '
  188. col.med.data:
  189.   DATA 777,000,700,060
  190. RETURN
  191. ' **********
  192. '
  193. > PROCEDURE standard.low.colors
  194.   ' *** standard-colors for Low resolution
  195.   LOCAL n&,col$,r&,g&,b&
  196.   RESTORE col.low.data
  197.   FOR n&=0 TO 15
  198.     READ col$
  199.     r&=VAL(LEFT$(col$))
  200.     g&=VAL(MID$(col$,2,1))
  201.     b&=VAL(RIGHT$(col$))
  202.     VSETCOLOR n&,r&,g&,b&
  203.   NEXT n&
  204.   '
  205. col.low.data:
  206.   DATA 777,000,700,060,007,005,520,050,555,111,077,053,707,505,550,770
  207. RETURN
  208. ' **********
  209. '
  210. > PROCEDURE start.date.input
  211.   ' *** input of date
  212.   ' *** accepts different formats (day-month-year), e.g. :
  213.   ' *** 1-6-'88   02-11-88   3.6.88   2/1/88   12 June 1988   9 Aug 88
  214.   LOCAL x&,y&,date.input$,ok!,day$,day&,month.input$,month$,n&,month!,month&,year$,year&
  215.   LOCAL new.date$
  216.   PRINT " Date (dd.mm.yy)   : ";
  217.   x&=CRSCOL
  218.   y&=CRSLIN
  219.   ON ERROR GOSUB start.date.input.error
  220.   '
  221. start.date.input:
  222.   ' *** input of date
  223.   ok!=TRUE
  224.   FORM INPUT 18,date.input$
  225.   ' *** day
  226.   day.len&=VAL?(date.input$)
  227.   IF day.len&>2
  228.     IF INSTR(date.input$,".")=2
  229.       day.len&=1
  230.     ELSE
  231.       IF INSTR(date.input$,".")=3
  232.         day.len&=2
  233.       ELSE
  234.         ok!=FALSE
  235.       ENDIF
  236.     ENDIF
  237.   ENDIF
  238.   day$=LEFT$(date.input$,day.len&)
  239.   day&=VAL(day$)
  240.   IF day&>31 OR day&<1
  241.     ok!=FALSE
  242.   ENDIF
  243.   ' *** mmonth
  244.   month.input$=RIGHT$(date.input$,LEN(date.input$)-(day.len&+1))
  245.   month.len&=VAL?(month.input$)
  246.   IF month.len&=0
  247.     month$=LEFT$(month.input$,3)
  248.     month$=UPPER$(month$)
  249.   start.month.data:
  250.     DATA JAN,1,FEB,2,MAR,3,APR,4,MAY,5,JUN,6,JUL,7
  251.     DATA AUG,8,SEP,9,OCT,10,NOV,11,DEC,12
  252.     DIM date.input.month$(12),date.input.month&(12)
  253.     RESTORE start.month.data
  254.     FOR n&=1 TO 12
  255.       READ date.input.month$(n&),date.input.month&(n&)
  256.     NEXT n&
  257.     FOR n&=1 TO 12
  258.       IF date.input.month$(n&)=month$
  259.         month!=TRUE
  260.         month&=date.input.month&(n&)
  261.       ENDIF
  262.     NEXT n&
  263.     ERASE date.input.month$()
  264.     ERASE date.input.month&()
  265.     IF NOT month!
  266.       ok!=FALSE
  267.     ENDIF
  268.   ELSE
  269.     month&=VAL(month.input$)
  270.   ENDIF
  271.   IF month&>12 OR month&<1
  272.     ok!=FALSE
  273.   ENDIF
  274.   month$=STR$(month&)
  275.   IF (month&=4 OR month&=6 OR month&=9 OR month&=11) AND day&>30
  276.     ok!=FALSE
  277.   ENDIF
  278.   IF (month&=1 OR month&=3 OR month&=5 OR month&=7 OR month&=8 OR month&=10 OR month&=12) AND day&>31
  279.     ok!=FALSE
  280.   ENDIF
  281.   ' *** year
  282.   year$=RIGHT$(date.input$,2)
  283.   IF VAL?(year$)<>2 OR INSTR(year$,".") OR VAL(year$)<88
  284.     ok!=FALSE
  285.   ENDIF
  286.   year&=VAL(year$)
  287.   IF month&=2
  288.     IF day&>28
  289.       IF (year& MOD 400=0) AND day&<>29
  290.         ok!=FALSE
  291.       ELSE
  292.         IF year& MOD 100=0 AND (year& MOD 400<>0)
  293.           ok!=FALSE
  294.         ELSE
  295.           IF (year& MOD 4=0) AND day&<>29
  296.             ok!=FALSE
  297.           ELSE
  298.             IF (year& MOD 4<>0)
  299.               ok!=FALSE
  300.             ENDIF
  301.           ENDIF
  302.         ENDIF
  303.       ENDIF
  304.     ENDIF
  305.   ENDIF
  306.   ' *** print date
  307.   IF NOT ok!
  308.     PRINT CHR$(7);
  309.     PRINT AT(x&,y&);STRING$(LEN(date.input$)," ");
  310.     PRINT AT(x&,y&);"WRONG FORMAT !!";
  311.     PAUSE 50
  312.     PRINT AT(x&,y&);STRING$(18," ");
  313.     PRINT AT(x&,y&);"";
  314.     GOTO start.date.input
  315.   ENDIF
  316.   LET new.date$=day$+"."+month$+"."+year$
  317.   SETTIME TIME$,new.date$
  318.   ON ERROR
  319. RETURN
  320. ' ***
  321. > PROCEDURE start.date.input.error
  322.   ' *** unexpected error
  323.   ok!=FALSE
  324.   ON ERROR GOSUB start.date.input.error
  325.   RESUME NEXT
  326. RETURN
  327. ' **********
  328. '
  329. > PROCEDURE start.time.input
  330.   ' *** input of time (seconds optional)
  331.   ' *** <Return> = 00:00:00
  332.   ' *** accepts different formats, e.g. :
  333.   ' *** 12.40.10    1:30:25    20.45
  334.   '
  335.   LOCAL x&,y&,ok!,time.input$,hour.len&,hour$,minute.input$,minute.len&
  336.   LOCAL minute$,second$,second.input$,second.len&,new.time$
  337.   PRINT " Time (hh.mm[.ss]) : ";
  338.   x&=CRSCOL
  339.   y&=CRSLIN
  340.   ON ERROR GOSUB start.time.input.error
  341.   '
  342. start.time.input:
  343.   ' *** input of time
  344.   ok!=TRUE
  345.   FORM INPUT 10,time.input$
  346.   IF time.input$=""
  347.     LET new.time$="00:00:00"
  348.     GOTO start.time.exit
  349.   ENDIF
  350.   ' *** hour
  351.   hour.len&=VAL?(time.input$)
  352.   IF hour.len&>2
  353.     IF INSTR(time.input$,".")=2
  354.       hour.len&=1
  355.     ELSE
  356.       IF INSTR(time.input$,".")=3
  357.         hour.len&=2
  358.       ELSE
  359.         ok!=FALSE
  360.       ENDIF
  361.     ENDIF
  362.   ENDIF
  363.   hour$=LEFT$(time.input$,hour.len&)
  364.   IF VAL(hour$)>23
  365.     ok!=FALSE
  366.   ENDIF
  367.   ' *** minutes
  368.   LET minute.input$=RIGHT$(time.input$,LEN(time.input$)-(hour.len&+1))
  369.   LET minute.len&=VAL?(minute.input$)
  370.   IF minute.len&>2
  371.     IF INSTR(minute.input$,".")=2
  372.       LET minute.len&=1
  373.     ELSE
  374.       IF INSTR(minute.input$,".")=3
  375.         LET minute.len&=2
  376.       ELSE
  377.         ok!=FALSE
  378.       ENDIF
  379.     ENDIF
  380.   ENDIF
  381.   LET minute$=LEFT$(minute.input$,minute.len&)
  382.   IF VAL(minute$)>59
  383.     ok!=FALSE
  384.   ENDIF
  385.   ' *** seconds
  386.   IF minute.len&>=LEN(minute.input$)-1
  387.     second$="0"
  388.   ELSE
  389.     second.input$=RIGHT$(minute.input$,LEN(minute.input$)-(minute.len&+1))
  390.     second$=LEFT$(second.input$,2)
  391.     IF VAL(second$)>59
  392.       ok!=FALSE
  393.     ENDIF
  394.   ENDIF
  395.   ' *** tijd
  396.   IF NOT ok!
  397.     PRINT CHR$(7);
  398.     PRINT AT(x&,y&);STRING$(LEN(time.input$)," ");
  399.     PRINT AT(x&,y&);"WRONG !!";
  400.     PAUSE 50
  401.     PRINT AT(x&,y&);STRING$(10," ");
  402.     PRINT AT(x&,y&);"";
  403.     GOTO start.time.input
  404.   ENDIF
  405.   LET new.time$=hour$+":"+minute$+":"+second$
  406. start.time.exit:
  407.   SETTIME new.time$,DATE$
  408.   ON ERROR
  409. RETURN
  410. ' ***
  411. > PROCEDURE start.time.input.error
  412.   ' *** unexpected error
  413.   ok!=FALSE
  414.   ON ERROR GOSUB start.time.input.error
  415.   RESUME NEXT
  416. RETURN
  417. ' **********
  418. '
  419. > PROCEDURE fileselect(path$,default$,txt$,VAR file$)
  420.   ' *** use Fileselector with comment-line
  421.   ' *** comment-line max. 38 characters in all resolutions
  422.   ' *** uses Standard Function and Globals
  423.   PRINT AT(1,3);@center$(txt$)
  424.   GRAPHMODE 3
  425.   DEFFILL 1,1           ! black
  426.   BOUNDARY 0
  427.   IF high.res!
  428.     BOX 157,25,482,54
  429.     PLOT 157,25
  430.     PBOX 159,27,480,52
  431.   ELSE IF med.res!
  432.     BOX 157,12,482,27
  433.     PLOT 157,12
  434.     PBOX 160,14,479,24
  435.   ELSE IF low.res!
  436.     BOX 0,12,319,27
  437.     PLOT 0,12
  438.     PBOX 2,14,317,24
  439.   ENDIF
  440.   BOUNDARY 1
  441.   GRAPHMODE 1
  442.   FILESELECT path$,default$,file$
  443. RETURN
  444. ' **********
  445. '
  446. > PROCEDURE parse.filename(parse.name$,VAR drive$,path$,file$,ext$)
  447.   ' *** return drive, path, filename (without extension !) and extension
  448.   ' *** no checking for correct syntax
  449.   ' *** example : "A:\GAMES\PLAY.GFA" returned as :  A  \GAMES\  PLAY  GFA
  450.   ' ***           "A:\PLAY.GFA"       returned as :  A  \        PLAY  GFA
  451.   LOCAL pos&,first&,last&,last!,search&,parse.file$
  452.   '
  453.   parse.name$=UPPER$(parse.name$)
  454.   IF MID$(parse.name$,2,1)=":"
  455.     drive$=LEFT$(parse.name$,1)
  456.   ELSE
  457.     drive$=CHR$(65+GEMDOS(&H19))    ! current drive
  458.   ENDIF
  459.   '
  460.   pos&=1
  461.   last!=FALSE
  462.   last&=0
  463.   first&=INSTR(1,parse.name$,"\")
  464.   REPEAT
  465.     search&=INSTR(pos&,parse.name$,"\")
  466.     IF search&>0
  467.       pos&=search&+1
  468.       last&=search&
  469.     ELSE
  470.       last!=TRUE
  471.     ENDIF
  472.   UNTIL last!
  473.   IF last&>0                              ! backslash discovered
  474.     path$=MID$(parse.name$,first&,last&-first&+1)
  475.     parse.file$=MID$(parse.name$,last&+1)
  476.   ELSE                                   ! no '\'
  477.     path$=""
  478.     pos&=INSTR(1,parse.name$,":")
  479.     IF pos&>0
  480.       parse.file$=MID$(parse.name$,pos&+1)
  481.     ELSE
  482.       parse.file$=parse.name$
  483.     ENDIF
  484.   ENDIF
  485.   pos&=INSTR(parse.file$,".")
  486.   IF pos&>0                               ! name with extension
  487.     ext$=MID$(parse.file$,pos&+1)
  488.     file$=LEFT$(parse.file$,pos&-1)
  489.   ELSE                                   ! name without extension
  490.     ext$=""
  491.     file$=parse.file$
  492.   ENDIF
  493. RETURN
  494. ' **********
  495. '
  496.